home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DIALOGS
/
JANUSW
/
VBX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-11-14
|
35KB
|
1,041 lines
{ Unit: Vbx
Version: 1.00
Purpose: DYNAMIC link to Borlands BIVBX10
Developer: Peter Sawatzki (ps)
Buchenhof 3, 58091 Hagen, Germany
CompuServe: 100031,3002
Contributing:
Ron Loewy (rl) [100274,162]
Frank Lee Lees (fl) [71532,2133]
Date: Author:
02/14/94 ps initial release by ps
02/24/94 rl/ps added tVbxControl object
02/25/94 ps fix the Ss:[0020] issue
02/26/94 ps add VBX event routing
02/28/94 rl add tVbxControl needed set/get prop.
02/28/94 ps add more methods to tVbxControl
03/12/94 ps add tVbxControl.SetPropStr/Data
03/16/94 fl/ps add tVbxWindow, correct tPicture, add LoadPicture
03/20/94 fl/ps add Set/GetArrayProp
03/31/94 sfs add ....
(c) 1994 Peter Sawatzki
based in part on Borland's BIVBX.H.
}
{$A+,B-,F-,G+,I-,K+,P-,Q-,R-,S-,T-,V-,X+}
Unit Vbx;
Interface
Uses
Objects,
WinTypes,
WinProcs,
Strings,
oWindows,
oDialogs,
{$IfDef Debug} Debug, {$EndIf}
DynLink;
Const
BIVBX10 = 'BIVBX10.DLL';
rt_DlgInit = pChar(240);
wm_VbxFireEvent = $0360;
PType_CString = $01; { HSZ }
PType_Short = $02; { short }
PType_Long = $03; { LONG }
PType_Bool = $04; { BOOL }
PType_Color = $05; { COLORREF or DWORD }
PType_Enum = $06; { BYTE }
PType_Real = $07; { float }
PType_XPos = $08; { LONG (twips) }
PType_XSize = $09; { LONG (twips) }
PType_YPos = $0A; { LONG (twips) }
PType_YSize = $0B; { LONG (twips) }
PType_Picture = $0C; { HPIC }
PType_BString = $0D; { HLSTR }
{ color properties }
Color_SysColor = $80000000;
Function MakeSysColor (iColor: tColorRef): tColorRef;
Inline($58 {Pop Ax} / $5A {Pop Dx} / $80/$CE/$80 {Or Dh, $80});
Type
Err = Bool;
hCtl = Pointer;
hPic = Word;
hSz = pChar;
hLStr = Pointer;
hFormFile = tHandle;
{-VBX event structure}
pVbxEvent = ^tVbxEvent;
tVbxEvent = Record
Control: hCtl;
Window: hWnd;
Id,
EventIndex: Integer;
EventName: pChar;
NumParams: Integer;
ParamList: Pointer
End;
{ pictures }
tPicType = (PicType_None, PicType_Bitmap, PicType_MetaFile, PicType_Icon);
pPicture = ^tPicture;
tPicture = Record
picType: tPicType;
PicData: Record Case tpicType Of
PicType_None: ();
PicType_Bitmap: (Bitmap: hBitmap; {bitmap}
Palette: hPalette); {accompanying palette}
PicType_MetaFile: (Metafile: tHandle; {Metafile}
xExtent, yExtent: Integer); {extent}
PicType_Icon: (Icon: hIcon) {Icon}
End;
unused0, unused1, unused2, unused3: Byte
End;
{ array property structure }
pElementStruct = ^tElementStruct;
tElementStruct = Record
Value: LongInt; { Data for Get/Set }
NumElems: Word; { Number of indecies }
Element: Array[0..0] Of Record
ElementType: Word; { Type of nth element }
Index: LongInt; { Index of nth element }
End
End;
pVbx = ^tVbx;
tVBX = Object(tDll)
Development: Boolean;
{Initialization}
VBXInit: Function (Instance: tHandle; classPrefix: pChar): Bool;
VBXTerm: Procedure;
VBXEnableDLL: Function (instApp, instDLL: tHandle): Bool;
VBXLoadVbx: Function (Name: pChar): Bool;
VBXInitHost: Function (Instance: tHandle; classPrefix: pChar; Mode: Integer;
Application: pChar; p1, p2: Pointer): Bool;
{Controls}
VBXGetHctl: Function (window: hWnd): hCtl;
VBXGetHwnd: Function (control: hCtl): hWnd;
VBXCreate: Function (windowParent: hWnd; id: Integer;
lib, cls, title: pChar; style: LongInt;
x, y, w, h: Integer; aFile: hFormFile): hCtl;
{Dialogs}
VBXInitDialog: Function (window: hWnd; instance: tHandle; id: pChar): Bool;
{Properties}
VBXGetNumProps: Function (control: hCtl): Integer;
VBXGetProp: Function (control: hCtl; index: Integer; Var Value): Bool;
VBXGetPropByName: Function (control: hCtl; name: pChar; Var Value): ERR;
VBXGetPropIndex: Function (control: hCtl; name: pChar): Integer;
VBXGetPropName: Function (control: hCtl; index: Integer): pChar;
VBXGetPropType: Function (control: hCtl; index: Integer): Word;
VBXIsArrayProp: Function (control: hCtl; index: Integer): Bool;
VBXSetProp: Function (control: hCtl; index: Integer; Value: LongInt): Bool;
VBXSetPropByName: Function (control: hCtl; name: pChar; value: LongInt): Err;
VBXGetModelPropInfo: Function (control: hCtl; index: Integer): Pointer;
{Events}
VBXGetEventIndex: Function (control: hCtl; name: pChar): Integer;
VBXGetEventName: Function (control: hCtl; index: Integer): pChar;
VBXGetNumEvents: Function (control: hCtl): Integer;
VBXGetModelEventInfo: Function (control: hCtl; Index: Integer): Pointer;
{methods}
VBXMethod: Function (control: hCtl; Method: Integer; Var Args): Bool;
VBXMethodAddItem: Function (control: hCtl; Index: Integer; Item: pChar): Bool;
VBXMethodDrag: Function (control: hCtl; Action: Integer): Bool;
VBXMethodMove: Function (control: hCtl; x,y,w,h: LongInt): Bool;
VBXMethodRefresh: Function (control: hCtl): Bool;
VBXMethodRemoveItem: Function (control: hCtl; item: Integer): Bool;
{pixel/twips conversions}
VBXTwp2PixY: Function (twips: LongInt): Integer;
VBXTwp2PixX: Function (twips: LongInt): Integer;
VBXPix2TwpY: Function (pixels: Integer): LongInt;
VBXPix2TwpX: Function (pixels: Integer): LongInt;
{dynamic strings}
VBXCreateCString: Function (segment: tHandle; str: pChar): hSz;
VBXGetCStringPtr: Function (str: hSz): pChar;
VBXDestroyCString: Function (str: hSz): hSz;
VBXLockCString: Function (str: hSz): pChar;
VBXUnlockCString: Procedure (str: hSz);
{pictures}
VBXCreatePicture: Function (picture: pPicture): hPic;
VBXDestroyPicture: Procedure (pic: hPic);
VBXGetPicture: Function (pic: hPic; picture: pPicture): hPic;
VBXGetPictureFromClipboard: Function (Var pic: hPic; data: tHandle; format: Word): Err;
VBXReferencePicture: Function (pic: hPic): hPic;
{Basic language strings}
VBXCreateBasicString: Function (buffer: Pointer; len: Word): hLStr;
VBXGetBasicStringPtr: Function (str: hLStr): pChar;
VBXDestroyBasicString: Procedure (str: hLStr);
VBXGetBasicStringLength: Function (str: hLStr): Word;
VBXSetBasicString: Function (Var str: hLStr; buffer: Pointer; len: Word): ERR;
{form files}
VBXCreateFormFile: Function (len: LongInt; data: Pointer): hFormFile;
VBXDeleteFormFile: Function (aFile: hFormFile): Bool;
VBXSaveProperties: Function (control: hCtl): hFormFile;
VbxGetFormFileLength: Function (aFile: hFormFile): LongInt;
{class functions}
VBXGetFirstClass: Function: Pointer;
VBXGetNextClass: Function (aClass: Pointer): Pointer;
Constructor Init (ForDevelopment: Boolean);
Procedure InitProcs; Virtual;
Function LibLink: Bool; Virtual;
Procedure LibUnLink; Virtual;
Function CreateControl (WindowParent: hWnd; wId: Integer; LibClsTitle: pChar; dwStyle: LongInt;
x, y, w, h: Integer; InitInfo: Pointer): hWnd;
Function LoadPicture (Name: pChar; aPicType: tPicType): hPic;
End;
Var
dVBX: tVBX;
Const
ev_First = nf_First;
ev_Std_Last = $FFF;
Type
pVbxControl = ^tVbxControl;
tVbxControl = Object(tControl)
Ctl: hCtl;
VbxName,
VbxClass: pChar;
InitData: tHandle;
Constructor Init(aParent: pWindowsObject; anId: Integer;
aVbxName, aVbxClass, aTitle: pChar;
x, y, w, h: Integer;
Len: LongInt; Data: Pointer);
Constructor InitResource(aParent: pWindowsObject; anId: Integer);
Destructor Done; Virtual;
Function Create: Boolean; Virtual;
Procedure wmVbxFireEvent (Var Msg: tMessage); Virtual wm_First+wm_VbxFireEvent;
Procedure DefaultEventProc (Var Event: tVbxEvent); Virtual;
Function GetHCtl: hCtl;
{properties}
Function GetNumProps: Integer;
Function GetPropIndex (Name: pChar): Integer;
Function GetPropName (Index: Integer): pChar;
Function GetPropType (Index: Integer): Integer;
Function IsArrayProp (Index: Integer): Bool;
Function GetPropByName (Name: pChar; Var Value): Bool;
Function GetProp (Index: Integer; Var Value): Bool;
Function GetPropStr (Index: Integer; Dst: pChar): Bool;
Function GetPropBStr (Index: Integer; Dst: pChar): Bool;
Function GetPropInt (Index: Integer; Var Value: Integer): Bool;
Function GetPropByte (Index: Integer; Var Value: Byte): Bool;
Function GetPropSingle (Index: Integer; Var Value: Single): Bool;
Function GetArrayProp (Index, ArrayIndex: Integer; Var Value: LongInt): Bool;
Function GetArrayPropStr (Index, ArrayIndex: Integer; Dst: pChar): Bool;
Function GetArrayPropBStr (Index, ArrayIndex: Integer; Dst: pChar): Bool;
Function GetArrayPropInt (Index, ArrayIndex: Integer; Var Value: Integer): Bool;
Function GetArrayPropByte (Index, ArrayIndex: Integer; Var Value: Byte): Bool;
Function GetArrayPropSingle (Index, ArrayIndex: Integer; Var Value: Single): Bool;
{SetProp}
Function SetPropByName (Name: pChar; Value: LongInt): Bool;
Function SetProp (Index: Integer; Value: LongInt): Bool;
Function SetPropInt (Index: Integer; Value: Integer): Bool;
Function SetPropByte (Index: Integer; Value: Byte): Bool;
Function SetPropSingle (Index: Integer; Value: Single): Bool;
Function SetPropStr (Index: Integer; aStr: pChar): Bool;
Function SetPropBStr (Index: Integer; aStr: pChar): Bool;
Function SetPropData (Index: Integer; Const Value): Bool;
Function SetArrayProp (Index, ArrayIndex: Integer; Value: LongInt): Bool;
Function SetArrayPropInt (Index, ArrayIndex: Integer; Value: Integer): Bool;
Function SetArrayPropByte (Index, ArrayIndex: Integer; Value: Byte): Bool;
Function SetArrayPropSingle (Index, ArrayIndex: Integer; Value: Single): Bool;
Function SetArrayPropStr (Index, ArrayIndex: Integer; aStr: pChar): Bool;
Function SetArrayPropBStr (Index, ArrayIndex: Integer; aStr: pChar): Bool;
{events}
Function GetNumEvents: Integer;
Function GetEventIndex (Name: pChar): Integer;
Function GetEventName (Index: Integer): pChar;
{methods}
Function Method (aMethod: Integer; Var Args): Bool;
Function AddItem (Index: Integer; Const Item: pChar): Bool;
Function Drag (Action: Integer): Bool;
Function Move (x, y, w, h: LongInt): Bool;
Function Refresh: Bool;
Function RemoveItem (Index: Integer): Bool;
End;
pVbxDialog = ^tVbxDialog;
tVbxDialog = Object(tDialog)
Constructor Init (aParent: pWindowsObject; aName: pChar);
Procedure SetupWindow; Virtual;
Procedure wmVbxFireEvent (Var Msg: tMessage); Virtual wm_First+wm_VbxFireEvent;
Procedure DefaultEventProc (Var Event: tVbxEvent); Virtual;
End;
pVbxDlgWindow = ^tVbxDlgWindow;
tVbxDlgWindow = Object(tDlgWindow)
Constructor Init (aParent: pWindowsObject; aName: pChar);
Procedure SetupWindow; Virtual;
Procedure wmVbxFireEvent (Var Msg: tMessage); Virtual wm_First+wm_VbxFireEvent;
Procedure DefaultEventProc (Var Event: tVbxEvent); Virtual;
End;
pVbxWindow = ^tVbxWindow;
tVbxWindow = Object(tWindow)
Procedure wmVbxFireEvent (Var Msg: tMessage); Virtual wm_First+wm_VbxFireEvent;
Procedure DefaultEventProc (Var Event: tVbxEvent); Virtual;
End;
Function EventPerform (W: pVbxControl; Var Event: tVbxEvent; DVMTIndex: Word): Boolean;
Function GetEventArg (Var Event: tVbxEvent; Index: Integer): Pointer;
{- define the Vbx ctl jump vector for Borland Pascal 7.0:
Every program that uses VBX controls must have a jump vector at
address SS:20h installed: it is absolutely neccessary to add the following
definition as the first typed constant statement to your main program:
Const
VbxValidation: tVbxValidation = cVbxValidation;
And to ensure that BP7's smartlinker does not remove this info,
one must 'use' the ValidationInfo at least once via a
RegisterVBX(VbxValidation) call.
The above makes sure that BIVBX10.DLL does not overwrite data at DS:20h
when the VBX jump vector gets installed. Consequently the dVBX object refuses
to link to BIVBX10 if the above conditions are not met!
}
Type
tVbxValidation = Array[$00..$13] Of Char;
Const
cVbxValidation = 'BIVBX10.DLL'#0' ps XXXX'; { 'XXXX' goes to adr SS:20h}
{dummy procedure for Validation Info registration}
Procedure RegisterVBX (Var ValidationInfo);
Implementation
Uses
Win31;
Function GetEventArg (Var Event: tVbxEvent; Index: Integer): Pointer;
Var
aPtr: Pointer;
Begin
If (Index<1) Or (Index>Event.NumParams) Then
Index:= 1;
aPtr:= Event.ParamList;
Inc(Word(aPtr), (Event.NumParams-Index) Shl 2);
GetEventArg:= Pointer(aPtr^)
End;
Constructor tVBX.Init (ForDevelopment: Boolean);
Begin
Inherited Init(BIVBX10);
Development:= ForDevelopment
End;
Procedure tVBX.InitProcs;
Begin
AddFunction(@@VBXCreate, pChar( 71));
AddFunction(@@VBXCreateBasicString, pChar( 93));
AddFunction(@@VBXCreateCString, pChar( 88));
AddFunction(@@VBXCreateFormFile, pChar( 54));
AddFunction(@@VbxGetFormFileLength, pChar( 55));
AddFunction(@@VBXSaveProperties, pChar( 56));
AddFunction(@@VBXCreatePicture, pChar(102));
AddFunction(@@VBXDeleteFormFile, pChar( 57));
AddFunction(@@VBXDestroyBasicString, pChar( 95));
AddFunction(@@VBXDestroyCString, pChar( 90));
AddFunction(@@VBXDestroyPicture, pChar(103));
AddFunction(@@VBXEnableDLL, pChar(110));
AddFunction(@@VBXGetBasicStringLength, pChar( 96));
AddFunction(@@VBXGetBasicStringPtr, pChar( 94));
AddFunction(@@VBXGetCStringPtr, pChar( 89));
AddFunction(@@VBXGetEventIndex, pChar( 35));
AddFunction(@@VBXGetEventName, pChar( 34));
AddFunction(@@VBXGetModelEventInfo, pChar( 11));
AddFunction(@@VBXGetHctl, pChar( 13));
AddFunction(@@VBXGetHwnd, pChar( 12));
AddFunction(@@VBXGetNumEvents, pChar( 37));
AddFunction(@@VBXGetNumProps, pChar( 39));
AddFunction(@@VBXGetPicture, pChar(104));
AddFunction(@@VBXGetPictureFromClipboard, pChar(105));
AddFunction(@@VBXGetProp, pChar( 17));
AddFunction(@@VBXGetPropByName, pChar( 85));
AddFunction(@@VBXGetPropIndex, pChar( 42));
AddFunction(@@VBXGetPropName, pChar( 44));
AddFunction(@@VBXGetPropType, pChar( 45));
AddFunction(@@VBXGetModelPropInfo, pChar( 10));
AddFunction(@@VBXInit, pChar( 14));
AddFunction(@@VBXInitHost, pChar( 19));
AddFunction(@@VBXInitDialog, pChar( 51));
AddFunction(@@VBXLoadVbx, pChar( 20));
AddFunction(@@VBXIsArrayProp, pChar( 87));
AddFunction(@@VBXLockCString, pChar( 91));
AddFunction(@@VBXMethod, pChar( 5));
AddFunction(@@VBXMethodAddItem, pChar( 6));
AddFunction(@@VBXMethodDrag, pChar( 69));
AddFunction(@@VBXMethodMove, pChar( 7));
AddFunction(@@VBXMethodRefresh, pChar( 8));
AddFunction(@@VBXMethodRemoveItem, pChar( 9));
AddFunction(@@VBXPix2TwpX, pChar(101));
AddFunction(@@VBXPix2TwpY, pChar(100));
AddFunction(@@VBXReferencePicture, pChar(106));
AddFunction(@@VBXSetBasicString, pChar( 97));
AddFunction(@@VBXSetProp, pChar( 16));
AddFunction(@@VBXSetPropByName, pChar( 82));
AddFunction(@@VBXTerm, pChar( 15));
AddFunction(@@VBXTwp2PixX, pChar( 99));
AddFunction(@@VBXTwp2PixY, pChar( 98));
AddFunction(@@VBXUnlockCString, pChar( 92));
AddFunction(@@VBXGetFirstClass, pChar( 24));
AddFunction(@@VBXGetNextClass, pChar( 25));
End;
Function tVBX.LibLink: Bool;
Begin
{-check if the VBX jump vector is at SS:20h}
If StrComp(Ptr(DSeg, $10), ModuleName)<>0 Then Begin
MessageBox(0, 'No VBX ctl jump vector found', 'Fatal Error', mb_IconExclamation+mb_Ok);
Halt
End;
If Inherited LibLink Then
If Development Then
LibLink:= VbxInitHost(System.hInstance,'Thunder',1,'JanusW',Nil,Nil)
Else
LibLink:= VBXInit(System.hInstance, 'Thunder')
Else
LibLink:= False
End;
Procedure tVBX.LibUnLink;
Begin
If ModuleHandle<>0 Then
VBXTerm;
Inherited LibUnLink
End;
Function VBReadFormFile (hForm: tHandle; Data: Pointer; cb: Word): Word;
Inline($BB/$3C/$00/ $36/$FF/$2E/$20/$00); {Mov Bx,$3C; Jmp [SS:20]}
Function VBSeekFormFile (hForm: tHandle; Offset: LongInt): LongInt;
Inline($BB/$A0/$00/ $36/$FF/$2E/$20/$00); {Mov Bx,$A0; Jmp [SS:20]}
Function IncPtrMac (aPtr: Pointer; anOffset: Word): Pointer;
Inline(
$5B/ { Pop Bx ; anOffset}
$58/ { Pop Ax ; Word(aPtr)}
$5A/ { Pop Dx ; Word(aPtr+2)}
$01/$D8/ { Add Ax,Bx}
$73/$04/ { Jnc @@1}
$03/$16/>SelectorInc); { Add Dx,[>SelectorInc]}
{@@1:}
Function tVBX.CreateControl (WindowParent: hWnd; wId: Integer;
LibClsTitle: pChar; dwStyle: LongInt;
x, y, w, h: Integer; InitInfo: Pointer): hWnd;
Type
{-structure of the rt_DlgInit data}
pDlgInitInfo = ^tDlgInitInfo;
tDlgInitInfo = Record
Id,
Version: Word;
Len: LongInt;
Data: Array[0..0{Len-1}] Of Byte
End;
Var
VbCtl: hCtl;
Combi: Array[0..77] Of Char;
Cls, Title: pChar;
Form: hFormFile;
prevMode: Word;
Begin
StrCopy(Combi, LibClsTitle);
Title:= Nil;
Cls:= StrScan(Combi, ';');
If Assigned(Cls) Then Begin
Cls[0]:= #0;
Inc(Cls);
Title:= StrScan(Cls, ';');
If Assigned(Title) Then Begin
Title[0]:= #0;
Inc(Title)
End
End;
Form:= 0;
If Assigned(InitInfo) Then Begin
While pDlgInitInfo(InitInfo)^.Id<>0 Do With pDlgInitInfo(InitInfo)^ Do Begin
If Id=wId Then Begin
Form:= dVbx.VbxCreateFormFile(Len, @Data);
If Integer(Form)=-1 Then
Form:= 0;
Break
End;
InitInfo:= IncPtrMac(InitInfo, SizeOf(tDlgInitInfo)+Len-1)
End
End;
prevMode:= SetErrorMode($8000); {SEM_NoOpenFileErrorBox}
VbCtl:= VBXCreate(WindowParent, wId, Combi, Cls, Title, dwStyle, x, y, w, h, Form);
SetErrorMode(prevMode);
If Form<>0 Then
VbxDeleteFormFile(Form);
CreateControl:= VBXGetHwnd(VbCtl)
End;
Function tVbx.LoadPicture (Name: pChar; aPicType: tPicType): hPic;
{ Load Graphic resource and return VB HPic}
{-Returns 0 if Resource not found }
Var
aPicture: tPicture;
Begin
LoadPicture:= 0;
aPicture.picType:= aPicType;
With aPicture, picData Do Case picType Of
PicType_Bitmap: Begin
Bitmap:=LoadBitmap(System.hInstance, Name);
If Bitmap=0 Then Begin
{$IfDef Debug} WriteLn('Could not find BITMAP Resource', StrPasEx(Name)); {$EndIf}
Exit
End Else Begin
Palette:=GetStockObject(Default_Palette);
LoadPicture:=dVbx.VBXCreatePicture(@aPicture)
End
End; {BITMAP}
PicType_MetaFile: ; { not yet implemented }
PicType_Icon: Begin
Icon:=LoadIcon(System.hInstance,Name);
If Icon=0 Then Begin
{$IfDef Debug} WriteLn('Could not find ICON Resource', StrPasEx(Name)); {$EndIf}
Exit
End Else
LoadPicture:=dVbx.VBXCreatePicture(@aPicture)
End {ICON}
End
End;
{-tVbxControl}
Constructor tVbxControl.Init(aParent: pWindowsObject; anId: Integer;
aVbxName, aVbxClass, aTitle: pChar;
x, y, w, h: Integer;
Len: LongInt; Data: Pointer);
Begin
Inherited Init (aParent, anId, aTitle, x, y, w, h);
VbxName:= StrNew(aVbxName);
If PtrRec(aVbxClass).Seg=0 Then
VbxClass:= aVbxClass
Else
VbxClass:= StrNew(aVbxClass);
Ctl:= Nil;
If (Len>0) And Assigned(Data) Then Begin
InitData:= GlobalAlloc(gMem_Fixed, Len);
If InitData<>0 Then Begin
hMemCpy(GlobalLock(InitData), Data, Len);
GlobalUnLock(InitData)
End
End Else
InitData:= 0;
Attr.Style:= 0
End;
Destructor tVbxControl.Done;
Begin
StrDispose(VbxName);
If PtrRec(VbxClass).Seg<>0 Then
StrDispose(VbxClass);
If InitData<>0 Then
GlobalFree(InitData);
Inherited Done
End;
Constructor tVbxControl.InitResource(aParent: pWindowsObject; anId: Integer);
Begin
Inherited InitResource(aParent, anId);
DisableTransfer; {as long as we don't know what to do with it <g>}
VbxName:= Nil;
VbxClass:= Nil;
Ctl:= Nil;
InitData:= 0
End;
Function tVbxControl.Create: Boolean;
Var
hParent: hWnd;
Form: hFormFile;
p: Pointer;
Begin
If Status=0 Then Begin
DisableAutoCreate;
If Assigned(Parent) Then hParent:= Parent^.hWindow Else hParent:= 0;
If IsFlagSet(wb_FromResource) Then Begin { Windows already created window }
hWindow:= GetDlgItem(hParent, Attr.Id);
Ctl:= dVbx.VBXGetHCtl(hWindow)
End Else Begin
If InitData=0 Then
Form:= 0
Else Begin
Form:= dVbx.VbxCreateFormFile(GlobalSize(InitData), GlobalLock(InitData));
GlobalUnlock(InitData);
GlobalFree(InitData);
InitData:= 0
End;
If Integer(Form)<>-1 Then Begin
With Attr Do
Ctl:= dVbx.VBXCreate(hParent, Id, VbxName, VbxClass, Title, Style, x, y, w, h, Form);
If Form<>0 Then
dVbx.VbxDeleteFormFile(Form);
hWindow:= dVbx.VbxGetHWnd(Ctl)
End
End;
If Assigned(Ctl) Then Begin
If GetObjectPtr(hWindow)=Nil Then Begin
p:= @Self;
With PtrRec(p) Do Begin {attach standard OWL properties}
WinProcs.SetProp(hWindow, 'OW1', Seg);
WinProcs.SetProp(hWindow, 'OW2', Ofs)
End;
DefaultProc:= tFarProc(SetWindowLong(hWindow, gwl_WndProc, LongInt(Instance)));
SetupWindow
End
End Else
Status:= em_InvalidWindow
End;
Create:= Status=0
End;
Type
{ Virtual method table }
tVMT = Record
InstSize: Word;
NegCheckSum: Word;
DMTPtr: Word;
Reserved: Word;
EntryTable: Record End
End;
{ Dynamic method table }
tDMT = Record
Parent: Word;
CacheIndex: Word;
CacheEntry: Word;
EntryCount: Word;
EntryTable: Record End
End;
{ search the pVbxControl's DVMT if a method for the passed event exists. Call the
method if found and return TRUE. Return FALSE if no method found.}
Function EventPerform (W: pVbxControl; Var Event: tVbxEvent; DVMTIndex: Word): Boolean;
Assembler;
Asm
Mov Ax, DVMTIndex
Les Bx, W
Mov Bx, Es:[Bx]
Mov Si, [Bx].tVMT.DMTPtr
Or Si, Si; Je @@NotFound
Cmp Ax, [Si].tDMT.CacheIndex; Jne @@Start
Mov Di, [Si].tDMT.CacheEntry; Jmp @@Found
@@Start:
Mov Di, Ds
Mov Es, Di
Cld
@@Continue:
Mov Cx, [Si].tDMT.EntryCount
Lea Di, [Si].tDMT.EntryTable
RepNE ScasW
Je @@Calculate
Mov Si, Es:[Si].tDMT.Parent
Or Si,Si; Jne @@Continue
@@NotFound:
Mov Ax, False
Jmp @@Done
@@Calculate:
Mov Dx, [Si].tDMT.EntryCount
Dec Dx; Shl Dx,1; Sub Dx,Cx; Shl Dx,1; Add Di, Dx
Mov Si, [Bx].tVMT.DMTPtr
Mov [Si].tDMT.CacheIndex,Ax
Mov [Si].tDMT.CacheEntry,Di
@@Found:
Les Bx, Event; Push Es; Push Bx {Event}
Les Bx, W; Push Es; Push Bx {Self}
Call DWord Ptr [Di]
Mov Ax, True
@@Done:
End;
Procedure tVbxControl.wmVbxFireEvent (Var Msg: tMessage);
Var
Event: tVbxEvent;
Begin
Event:= pVbxEvent(Msg.lParam)^;
If Not EventPerform(@Self, Event, ev_First+Event.EventIndex) Then
DefaultEventProc(Event);
Msg.Result:= 0
End;
{the default Event proc is called if no event method is defined for
the incoming event}
Procedure tVbxControl.DefaultEventProc (Var Event: tVbxEvent);
Begin
End;
Function tVbxControl.GetHCtl: hCtl;
Begin
GetHCtl:= Ctl
End;
{-properties}
Function tVbxControl.GetNumProps: Integer;
Begin
GetNumProps:= dVbx.VbxGetNumProps(Ctl)
End;
Function tVbxControl.GetPropIndex (Name: pChar): Integer;
Begin
GetPropIndex:= dVbx.VbxGetPropIndex(Ctl, Name)
End;
Function tVbxControl.GetPropName (Index: Integer): pChar;
Begin
GetPropName:= dVbx.VbxGetPropName(Ctl, Index)
End;
Function tVbxControl.GetPropType (Index: Integer): Integer;
Begin
GetPropType:= dVbx.VbxGetPropType(Ctl, Index)
End;
Function tVbxControl.IsArrayProp (Index: Integer): Bool;
Begin
IsArrayProp:= dVbx.VbxIsArrayProp(Ctl, Index)
End;
Function tVbxControl.GetPropByName (Name: pChar; Var Value): Bool;
Begin
GetPropByName:= dVbx.VbxGetPropByName(Ctl, Name, Value)
End;
Function tVbxControl.GetProp (Index: Integer; Var Value): Bool;
Begin
GetProp:= dVbx.VbxGetProp(Ctl, Index, Value)
End;
Function tVbxControl.GetPropStr (Index: Integer; Dst: pChar): Bool;
Var
strHandle: LongInt;
Begin
If dVbx.VbxGetProp(Ctl, Index, strHandle) Then Begin
StrCopy(Dst, dVbx.VbxGetCStringPtr(hSz(strHandle)));
dVbx.VbxDestroyCString(hSz(strHandle));
GetPropStr:= True
End Else
GetPropStr:= False
End;
Function tVbxControl.GetPropBStr (Index: Integer; Dst: pChar): Bool;
Var
aStr: hLStr;
i, Len: Integer;
p: pChar;
Begin
GetPropBStr:= dVbx.VbxGetProp(Ctl, Index, aStr);
Len:= dVbx.VBXGetBasicStringLength(aStr);
p:= dVbx.VBXGetBasicStringPtr(aStr);
For i:= 0 To Len-1 Do
Dst[i]:= p[i];
Dst[Len]:= #0;
dVbx.VBXDestroyBasicString(HLSTR(aStr))
End;
Function tVbxControl.GetPropInt (Index: Integer; Var Value: Integer): Bool;
Var
aLong: LongInt;
Begin
GetPropInt:= dVbx.VbxGetProp(Ctl, Index, aLong);
Value:= Integer(aLong)
End;
Function tVbxControl.GetPropByte (Index: Integer; Var Value: Byte): Bool;
Var
aLong: LongInt;
Begin
GetPropByte:= dVbx.VbxGetProp(Ctl, Index, aLong);
Value:= Byte(aLong)
End;
Function tVbxControl.GetPropSingle (Index: Integer; Var Value: Single): Bool;
Begin
GetPropSingle:= dVbx.VbxGetProp(Ctl, Index, LongInt(Value))
End;
Function tVbxControl.GetArrayProp (Index, ArrayIndex: Integer; Var Value: LongInt): Bool;
Var
anElement: tElementStruct;
Begin
anElement.NumElems:= 1;
anElement.Element[0].ElementType:= PType_Short;
anElement.Element[0].Index:= ArrayIndex;
GetArrayProp:= dVbx.VbxGetProp(Ctl, Index, anElement);
Value:= anElement.Value
End;
Function tVbxControl.GetArrayPropStr (Index, ArrayIndex: Integer; Dst: pChar): Bool;
Var
strHandle: LongInt;
Begin
If GetArrayProp(Index, ArrayIndex, strHandle) Then Begin
StrCopy(Dst, dVbx.VbxGetCStringPtr(hSz(strHandle)));
dVbx.VbxDestroyCString(hSz(strHandle));
GetArrayPropStr:= True
End Else
GetArrayPropStr:= False
End;
Function tVbxControl.GetArrayPropBStr (Index, ArrayIndex: Integer; Dst: pChar): Bool;
Var
aStr: hLStr;
i, Len: Integer;
p: pChar;
Begin
GetArrayPropBStr:= GetArrayProp(Index, ArrayIndex, LongInt(aStr));
Len:= dVbx.VBXGetBasicStringLength(aStr);
p:= dVbx.VBXGetBasicStringPtr(aStr);
For i:= 0 To Len-1 Do
Dst[i]:= p[i];
Dst[Len]:= #0;
dVbx.VBXDestroyBasicString(HLSTR(aStr))
End;
Function tVbxControl.GetArrayPropInt (Index, ArrayIndex: Integer; Var Value: Integer): Bool;
Var
aLong: LongInt;
Begin
GetArrayPropInt:= GetArrayProp(Index, ArrayIndex, aLong);
Value:= Integer(aLong)
End;
Function tVbxControl.GetArrayPropByte (Index, ArrayIndex: Integer; Var Value: Byte): Bool;
Var
aLong: LongInt;
Begin
GetArrayPropByte:= GetArrayProp(Index, ArrayIndex, aLong);
Value:= Byte(aLong)
End;
Function tVbxControl.GetArrayPropSingle (Index, ArrayIndex: Integer; Var Value: Single): Bool;
Begin
GetArrayPropSingle:= GetArrayProp(Index, ArrayIndex, LongInt(Value))
End;
Function tVbxControl.SetProp (Index: Integer; Value: LongInt): Bool;
Begin
SetProp:= dVbx.VbxSetProp(Ctl, Index, Value)
End;
Function tVbxControl.SetPropByName (Name: pChar; Value: LongInt): Bool;
Begin
SetPropByName:= dVbx.VbxSetPropByName(Ctl, Name, Value)
End;
Function tVbxControl.SetPropInt (Index: Integer; Value: Integer): Bool;
Begin
SetPropInt:= dVbx.VbxSetProp(Ctl, Index, Value)
End;
Function tVbxControl.SetPropByte (Index: Integer; Value: Byte): Bool;
Begin
SetPropByte:= dVbx.VbxSetProp(Ctl, Index, Value)
End;
Function tVbxControl.SetPropSingle (Index: Integer; Value: Single): Bool;
Begin
SetPropSingle:= dVbx.VbxSetProp(Ctl, Index, LongInt(Value))
End;
Function tVbxControl.SetPropStr (Index: Integer; aStr: pChar): Bool;
Begin
SetPropStr:= dVbx.VbxSetProp(Ctl, Index, LongInt(aStr))
End;
Function tVbxControl.SetPropBStr (Index: Integer; aStr: pChar): Bool;
Var
aBStr: hLStr;
Begin
aBStr:= dVbx.VBXCreateBasicString(aStr, StrLen(aStr));
SetPropBStr:= dVbx.VbxSetProp(Ctl, Index, LongInt(@aBStr));
dVbx.VBXDestroyBasicString(aBStr)
End;
Function tVbxControl.SetPropData (Index: Integer; Const Value): Bool;
Begin
SetPropData:= dVbx.VbxSetProp(Ctl, Index, LongInt(@Value))
End;
Function tVbxControl.SetArrayProp (Index, ArrayIndex: Integer; Value: LongInt): Bool;
Var
anElement: tElementStruct;
Begin
anElement.Value:= Value;
anElement.NumElems:= 1;
anElement.Element[0].ElementType:= PType_Short;
anElement.Element[0].Index:= ArrayIndex;
SetArrayProp:= SetPropData(Index, anElement)
End;
Function tVbxControl.SetArrayPropInt (Index, ArrayIndex: Integer; Value: Integer): Bool;
Begin
SetArrayPropInt:= SetArrayProp(Index, ArrayIndex, Value)
End;
Function tVbxControl.SetArrayPropByte (Index, ArrayIndex: Integer; Value: Byte): Bool;
Begin
SetArrayPropByte:= SetArrayProp(Index, ArrayIndex, Value)
End;
Function tVbxControl.SetArrayPropSingle (Index, ArrayIndex: Integer; Value: Single): Bool;
Begin
SetArrayPropSingle:= SetArrayProp(Index, ArrayIndex, LongInt(Value))
End;
Function tVbxControl.SetArrayPropStr (Index, ArrayIndex: Integer; aStr: pChar): Bool;
Begin
SetArrayPropStr:= SetArrayProp(Index, ArrayIndex, LongInt(aStr))
End;
Function tVbxControl.SetArrayPropBStr (Index, ArrayIndex: Integer; aStr: pChar): Bool;
Var
aBStr: hLStr;
Begin
aBStr:= dVbx.VBXCreateBasicString(aStr, StrLen(aStr));
SetArrayPropBStr:= SetArrayProp(Index, ArrayIndex, LongInt(@aBStr));
dVbx.VBXDestroyBasicString(aBStr)
End;
{events}
Function tVbxControl.GetNumEvents: Integer;
Begin
GetNumEvents:= dVbx.VbxGetNumEvents(Ctl)
End;
Function tVbxControl.GetEventIndex (Name: pChar): Integer;
Begin
GetEventIndex:= dVbx.VbxGetEventIndex(Ctl, Name)
End;
Function tVbxControl.GetEventName (Index: Integer): pChar;
Begin
GetEventName:= dVbx.VbxGetEventName(Ctl, Index)
End;
{methods}
Function tVbxControl.Method (aMethod: Integer; Var Args): Bool;
Begin
Method:= dVbx.VbxMethod(Ctl, aMethod, Args)
End;
Function tVbxControl.AddItem (Index: Integer; Const Item: pChar): Bool;
Begin
AddItem:= dVbx.VbxMethodAddItem (Ctl, Index, @Item)
End;
Function tVbxControl.Drag (Action: Integer): Bool;
Begin
Drag:= dVbx.VbxMethodDrag(Ctl, Action)
End;
Function tVbxControl.Move (x, y, w, h: LongInt): Bool;
Begin
Move:= dVbx.VbxMethodMove(Ctl, x, y, w, h)
End;
Function tVbxControl.Refresh: Bool;
Begin
Refresh:= dVbx.VbxMethodRefresh(Ctl)
End;
Function tVbxControl.RemoveItem (Index: Integer): Bool;
Begin
RemoveItem:= dVbx.VbxMethodRemoveItem(Ctl, Index)
End;
Constructor tVbxDialog.Init (aParent: pWindowsObject; aName: pChar);
Begin
If Not dVbx.LibLink Then Fail;
Inherited Init(aParent, aName);
End;
Procedure tVbxDialog.SetupWindow;
Begin
dVbx.VbxInitDialog(hWindow, System.hInstance, Attr.Name);
Inherited SetupWindow
End;
Procedure tVbxDialog.wmVbxFireEvent (Var Msg: tMessage);
Begin
If Not EventPerform(@Self, pVbxEvent(Msg.lParam)^, id_First+pVbxEvent(Msg.lParam)^.Id) Then
DefaultEventProc(pVbxEvent(Msg.lParam)^);
Msg.Result:= 0
End;
Procedure tVbxDialog.DefaultEventProc (Var Event: tVbxEvent);
Begin
With Event Do If GetObjectPtr(Window)<>Nil Then {route to object}
SendMessage(Window, wm_VbxFireEvent, 0, LongInt(@Event))
End;
Constructor tVbxDlgWindow.Init (aParent: pWindowsObject; aName: pChar);
Begin
If Not dVbx.LibLink Then Fail;
Inherited Init(aParent, aName);
End;
Procedure tVbxDlgWindow.SetupWindow;
Begin
dVbx.VbxInitDialog(hWindow, System.hInstance, Attr.Name);
Inherited SetupWindow
End;
Procedure tVbxDlgWindow.wmVbxFireEvent (Var Msg: tMessage);
Begin
If Not EventPerform(@Self, pVbxEvent(Msg.lParam)^, id_First+pVbxEvent(Msg.lParam)^.Id) Then
DefaultEventProc(pVbxEvent(Msg.lParam)^);
Msg.Result:= 0
End;
Procedure tVbxDlgWindow.DefaultEventProc (Var Event: tVbxEvent);
Begin
With Event Do If GetObjectPtr(Window)<>Nil Then {route to object}
SendMessage(Window, wm_VbxFireEvent, 0, LongInt(@Event))
End;
Procedure tVbxWindow.wmVbxFireEvent (Var Msg: tMessage);
Begin
If Not EventPerform(@Self, pVbxEvent(Msg.lParam)^, id_First+pVbxEvent(Msg.lParam)^.Id) Then
DefaultEventProc(pVbxEvent(Msg.lParam)^);
Msg.Result:= 0
End;
Procedure tVbxWindow.DefaultEventProc (Var Event: tVbxEvent);
Begin
With Event Do If GetObjectPtr(Window)<>Nil Then {route to object}
SendMessage(Window, wm_VbxFireEvent, 0, LongInt(@Event))
End;
{-just a wrapper procedure for Validation Info registration}
Procedure RegisterVBX (Var ValidationInfo);
Assembler; Asm End;
Var
PrevExit: Pointer;
Procedure VbxExit; Far;
Begin
ExitProc:= PrevExit;
dVBX.Done
End;
Begin
PrevExit:= ExitProc;
ExitProc:= @VbxExit;
dVbx.Init(False)
End.